home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / comp-util.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  6.4 KB  |  166 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;* 
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;* 
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;* 
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: comp-util.scm,v 1.12 1992/09/05 16:05:18 jmiller Exp $
  39.  
  40. ;;;; Utility procedures for use at compile time only
  41. ;;;;
  42. ;;;; Name operations: new-name, name->module-getter,
  43. ;;;;                  name->module-setter, name->setter,
  44. ;;;;                  variable->name, variable-name?,
  45. ;;;;                  name->keyword, dylan-special-name?
  46. ;;;; General: cant-parse, list-of-length?, list-of-at-least-length?,
  47. ;;;;          must-be-list-of-length, must-be-list-of-at-least-length,
  48. ;;;;          set-difference
  49. ;;;; Compiler specific: module-refs, add-variable, add-module-variable
  50.  
  51. ;;; Name operations.  These convert from Dylan names (including
  52. ;;; (SETTER x) and Keyword:) to Scheme forms.
  53.  
  54. ; new-name is now in support.scm, since it is used at runtime as well as compile time
  55.  
  56. (define (name->module-getter name)
  57.   (new-name "dylan:module-get/" (variable->name name) "/"))
  58. (define (name->module-setter name)
  59.   (new-name "dylan:module-set/" (variable->name name) "/!"))
  60.  
  61. (define (name->setter name)
  62.   (new-name "dylan:setter/" name "/"))
  63.  
  64. (define (name->scheme-safe-name name)
  65.   (new-name "dylan:scheme-safe/" name "/"))
  66.  
  67. (define scheme-reserved-names
  68.   '(=> and begin case cond define delay do else if lambda let let*
  69.        letrec or quasiquote quote set! unquote unquote-splicing))
  70.  
  71. (define (variable->name dylan-variable)
  72.   (if (symbol? dylan-variable)
  73.       (cond ((assq dylan-variable dylan::scheme-names-of-predefined-names)
  74.          => cadr)
  75.         ((memq dylan-variable scheme-reserved-names)
  76.          (name->scheme-safe-name dylan-variable))
  77.         (else dylan-variable))
  78.       (name->setter (cadr dylan-variable))))
  79.  
  80. (define (variable-name? x)
  81.   (define (simple-variable-name? x)
  82.     (and (symbol? x)
  83.      (not (keyword? x))
  84.      (not (dylan-special-name? x))))
  85.   (or (simple-variable-name? x)
  86.       (and (list-of-length? x 2)
  87.        (eq? (car x) 'SETTER)
  88.        (simple-variable-name? (cadr x)))))
  89.  
  90. (define (name->keyword symbol)
  91.   (new-name "" symbol ":"))
  92.  
  93. (define (dylan-special-name? x)
  94.   ;; The Scheme reader doesn't allow Dylan's #rest, etc. so we
  95.   ;; simulate them with !rest and preclude the use of variable names
  96.   ;; that begin with "dylan:" or "!"
  97.   (and (symbol? x)
  98.        (let* ((string (symbol->string x))
  99.           (length (string-length string))
  100.           (chars (string->list string)))
  101.      (or (and (> length 0) (char=? #\! (car chars)))
  102.          (and (> length 5) (string-ci=? "dylan:"
  103.                         (substring string 0 6)))))))
  104.  
  105. ; (keyword? obj) is used at runtime: see support.scm
  106.  
  107. ;;; General support operations needed only at compile time
  108.  
  109. (define (cant-parse reason orig-l l)
  110.   (dylan::error (string-append "illegal parameter list in " reason)
  111.         orig-l l))
  112.  
  113. (define (list-of-length? l n)
  114.   (cond ((and (= n 0) (null? l)) #T)
  115.     ((or (= n 0) (not (pair? l))) #F)
  116.     (else (list-of-length? (cdr l) (- n 1)))))
  117.  
  118. (define (list-of-at-least-length? l n)
  119.   (and (list? l)
  120.        (let loop ((l l) (n n))
  121.      (cond ((= n 0) #T)
  122.            ((not (pair? l)) #F)
  123.            (else (loop (cdr l) (- n 1)))))))
  124.  
  125. (define (must-be-list-of-length l n error-message)
  126.   (or (list-of-length? l n)
  127.       (dylan::error error-message l)))
  128.  
  129. (define (must-be-list-of-at-least-length l n error-message)
  130.   (or (list-of-at-least-length? l n)
  131.       (dylan::error error-message l)))
  132.  
  133. (define (module-refs
  134.      variable bound-vars module-vars continue core)
  135.   ;; Called to generate code to deal with direct references to module
  136.   ;; variables. name is the variable name, core is a procedure to
  137.   ;; generate the main body.
  138.   (let* ((name (variable->name variable))
  139.      (hidden? (memq name bound-vars)))
  140.     (continue
  141.      (if hidden?
  142.      `(LET ((!OLD-VALUE (,(name->module-getter name))))
  143.         ,(core '!OLD-VALUE
  144.            (lambda (val) `(,(name->module-setter name) ,val))))
  145.      (core name (lambda (val) `(SET! ,name ,val))))
  146.      (add-module-variable name hidden? module-vars))))
  147.  
  148. ;;; Compile a list of forms, producing a list of corresponding Scheme
  149. ;;; forms and the (updated) module variables.
  150.  
  151. (define (add-variable name bound-vars module-vars)
  152.   (if (or (memq name bound-vars)
  153.       (memq name dylan::predefined-variables))
  154.       module-vars
  155.       (adjoin name module-vars memq)))
  156.  
  157. (define (add-module-variable
  158.      name require-accessor-fns module-vars)
  159.   (if (or require-accessor-fns (not (memq name dylan::predefined-names)))
  160.       (adjoin name module-vars memq)
  161.       module-vars))
  162.  
  163. (define (must-be-unique objects predicate error-string)
  164.   (if (not (unique? objects predicate))
  165.       (dylan::error error-string (car objects) objects)))
  166.